home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 March / Macworld (1998-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / package.tcl < prev    next >
Encoding:
Text File  |  1997-12-15  |  34.3 KB  |  1,177 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Vince's Additions - an extension package for Alpha
  4.  # 
  5.  #  FILE: "package.tcl"
  6.  #                                    created: 2/8/97 {6:15:10 pm} 
  7.  #                                last update: 15/12/97 {2:27:05 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Copyright (c) 1997  Vince Darley
  15.  # 
  16.  #  How to ensure packages are loaded in the correct order?
  17.  #  (some may require Vince's Additions).  Here perhaps we could
  18.  #  just use a Tcl8-like-approach: introduce a 'package' command
  19.  #  and have stuff like 'package Name 1.0 script-to-load'.
  20.  #  Then a package can just do 'package require Othername' to ensure
  21.  #  it is loaded.  I like this approach.
  22.  #  
  23.  #  How to initialise each package at startup?  If we use the above
  24.  #  scheme, then the startup script is purely a sequence of
  25.  #  'package require Name' commands.  The file 'prefs.tcl' is then
  26.  #  purely for user-meddling.  Packages do not need to store anything
  27.  #  there.  Sounds good to me.
  28.  #  
  29.  #  How to uninstall things?  One approach here is a 
  30.  #  'package uninstall Name' command.  Nice packages would provide
  31.  #  this.
  32.  #  
  33.  #  We need a default behaviour too.  Some packages require no
  34.  #  installation at all (except placing in a directory), others 
  35.  #  require sourcing, others need to add something to a menu.  How
  36.  #  much of this should be automated and how much is up to the
  37.  #  package author?
  38.  # 
  39.  # ----
  40.  # 
  41.  #  The solution below is to imitate Tcl 8.  There is a 'package'
  42.  #  mechanism.  There exists a index::extension() array which gives for
  43.  #  each package the means to load it --- a procedure name or a
  44.  #  'source file' command.  The package index is compiled 
  45.  #  automatically by recursively scanning all files in the
  46.  #  Packages directory for 'package name version do-this'
  47.  #  commands.
  48.  #  
  49.  #  There's also 'package names', 'package exists name', and an
  50.  #  important 'package require name version' which allows one
  51.  #  package to autoload another...
  52.  #  
  53.  # Pros of this approach: many packages, which would otherwise
  54.  # require an installation procedure, now can be just dropped
  55.  # in to the packages directory and they're installed! (After
  56.  # rebuilding the package index).  This is because 'package'
  57.  # can declare a snippet of code, an addition to a menu etc…
  58.  # ----
  59.  # 
  60.  # Thanks to Tom Fetherston for some improvements here.
  61.  # ###################################################################
  62.  ##
  63.  
  64. namespace eval package {}
  65. namespace eval date {}
  66. namespace eval remote {}
  67.  
  68. lunion package::loaded "Alpha"
  69.  
  70. ## 
  71.  # -------------------------------------------------------------------------
  72.  # 
  73.  # "alpha::findAllExtensions" --
  74.  # 
  75.  #  package require all extensions the user has activated
  76.  # -------------------------------------------------------------------------
  77.  ##
  78. proc alpha::findAllExtensions {} {
  79.     global package::activate package::loaded modifiedVars
  80.     if [info exists package::activate] {
  81.         cache::delete packageMenu
  82.         lappend modifiedVars package::activate
  83.     }
  84.     if {${package::loaded} != ""} {
  85.         eval lappend package::activate ${package::loaded}
  86.         set package::loaded ""
  87.         foreach pkg ${package::activate} {
  88.             package::checkRequire $pkg
  89.         }
  90.     }
  91.     catch {unset package::activate}
  92. }
  93.  
  94. proc package::addPrefsDialog {pkg} {
  95.     global package::prefs alpha::noMenusYet
  96.     lunion package::prefs $pkg
  97.     if ![info exists alpha::noMenusYet] {
  98.         # we were called after start-up; build the menu now
  99.         menu::buildSome global
  100.     }
  101. }
  102.  
  103. ## 
  104.  # -------------------------------------------------------------------------
  105.  # 
  106.  # "alpha::package" --
  107.  # 
  108.  #  Mimics the Tcl standard 'package' command for use with Alpha.
  109.  #  It does however have some differences.
  110.  #  
  111.  #  package require ?-exact? ?-extension -mode -menu? name version
  112.  #  package exists ?-extension -mode -menu? name version
  113.  #  package names ?-extension -mode -menu?
  114.  #  package uninstall name version
  115.  #  package vcompare v1 v2
  116.  #  package vsatisfies v1 v2
  117.  #  package versions ?-extension -mode -menu? name
  118.  #  package type name
  119.  #  package info name
  120.  #  package maintainer name version {name email web-page}
  121.  #  
  122.  #  Equivalent to alpha::mode alpha::menu and alpha::extension
  123.  #  
  124.  #  package mode ...
  125.  #  package menu ...
  126.  #  package extension ...
  127.  #  
  128.  #  For extensions only:
  129.  #  
  130.  #  package forget name version
  131.  # -------------------------------------------------------------------------
  132.  ##
  133. proc alpha::package {cmd args} {
  134.     global index::extension
  135.     switch -- $cmd {
  136.         "require" {
  137.             set info [package::getInfo exact]
  138.             global alpha::rebuilding
  139.             if {$info != ""} {
  140.                 if {!${alpha::rebuilding} && [set version [lindex $args 1]] != ""} {
  141.                     if [info exists exact] {
  142.                         if {[lindex $info 0] != $version} {
  143.                             error "requested exact $version, had [lindex $info 0]"
  144.                         }
  145.                     } elseif {![alpha::package vsatisfies [lindex $info 0] $version]} {
  146.                         error "requested $version, had [lindex $info 0]"
  147.                     }
  148.                 }
  149.                 if {$type == "extension"} {
  150.                     global package::loaded alpha::noMenusYet \
  151.                       errorCode errorInfo
  152.                     if ![lcontains package::loaded $name] {
  153.                         message "Loading extension '$name'…"
  154.                         lappend package::loaded $name
  155.                         if [catch {uplevel \#0 [lindex $info 1]} res] {
  156.                             set package::loaded [lremove ${package::loaded} $name]
  157.                             return -code error -errorcode $errorCode \
  158.                               -errorinfo $errorInfo $res
  159.                         }
  160.                         if ![info exists alpha::noMenusYet] {
  161.                             package::markMenu $name 1
  162.                         }
  163.                     }
  164.                 }
  165.                 return [lindex $info 0]
  166.             }
  167.             if {!${alpha::rebuilding}} {
  168.                 error "can't find package $name"
  169.             }
  170.         }
  171.         "uninstall" {
  172.             set name [lindex $args 0]
  173.             if {[llength $args] > 2} {
  174.                 set version [lindex $args 1]
  175.                 global alpha::rebuilding 
  176.                 if {${alpha::rebuilding}} {
  177.                     global rebuild_cmd_count index::uninstall pkg_file
  178.                     switch -- [set script [lindex $args 2]] {
  179.                         "this-file" {
  180.                             set script [list removeFile $pkg_file]
  181.                         }
  182.                         "this-directory" {
  183.                             set script [list rm -r [file dirname $pkg_file]]
  184.                         }
  185.                     }
  186.                     set index::uninstall($name) [list $version $pkg_file $script]
  187.                     set args [lrange $args 3 end]
  188.                     if [llength $args] {
  189.                         eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  190.                         return
  191.                     }
  192.                     if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  193.                         return -code 11
  194.                     }
  195.                 }
  196.             } else {
  197.                 cache::read index::uninstall
  198.                 return [set index::uninstall($name)]
  199.             }
  200.         }
  201.         "forget" {
  202.             catch {unset index::extension($name)}
  203.         }
  204.         "exists" {
  205.             if {[package::getInfo] != ""} {return 1} else {return 0}
  206.         }
  207.         "type" {
  208.             if {[package::getInfo] != ""} {return $type} 
  209.             error "No such package"
  210.         }
  211.         "info" {
  212.             if {[set info [package::getInfo]] != ""} {return [concat $type $info]} 
  213.             error "No such package"
  214.         }
  215.         "maintainer" -
  216.         "disable" -
  217.         "help" {
  218.             set name [lindex $args 0]
  219.             if {[llength $args] > 2} {
  220.                 global alpha::rebuilding 
  221.                 if {${alpha::rebuilding}} {
  222.                     set version [lindex $args 1]
  223.                     global rebuild_cmd_count index::$cmd
  224.                     set data [lindex $args 2]
  225.                     set index::${cmd}($name) [list $version $data]
  226.                     set args [lrange $args 3 end]
  227.                     if [llength $args] {
  228.                         eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  229.                         return
  230.                     }
  231.                     if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  232.                         return -code 11
  233.                     }
  234.                 }
  235.             } else {
  236.                 cache::read index::$cmd
  237.                 return [set index::${cmd}($name)]
  238.             }
  239.         }
  240.         "versions" {
  241.             set info [package::getInfo]
  242.             if {$info != ""} {
  243.                 return [lindex $info 0]
  244.             }
  245.             error "No such package"
  246.         }
  247.         "vcompare" {
  248.             set c [eval package::_versionCompare $args]
  249.             if {$c > 0 || $c == -3} {
  250.                 return 1
  251.             } elseif {$c == 0} {
  252.                 return 0
  253.             } else {
  254.                 return -1
  255.             }
  256.         }
  257.         "vsatisfies" {
  258.             set c [eval package::_versionCompare $args]
  259.             return [expr $c >= 0 ? 1 : 0]
  260.         }
  261.         "names" {
  262.             set names ""
  263.             package::getInfo
  264.             foreach type $which {
  265.                 if [array exists index::${type}] {
  266.                     eval lappend names [array names index::${type}]
  267.                 }
  268.             }
  269.             return $names
  270.         }
  271.         "mode" -
  272.         "menu" -
  273.         "extension" {
  274.             eval alpha::$cmd $args
  275.         }
  276.         default {
  277.             error "Unknown option '$cmd' to 'package'"
  278.         }
  279.     }
  280. }
  281.  
  282. proc package::getInfo {{flags ""}} {
  283.     uplevel [list set flags $flags]
  284.     uplevel {
  285.         set name [lindex $args 0]
  286.         if {[regexp -- {-([^-].*)} $name "" which]} {
  287.             if {[lsearch $flags $which] != -1} {
  288.                 set $which 1
  289.                 set name [lindex $args 1]            
  290.                 set args [lrange $args 1 end]            
  291.                 return [package::getInfo $flags]
  292.             }
  293.             if {[lsearch {extension mode menu} $which] == -1} {
  294.                 error "No such flag -$which"
  295.             }
  296.             set name [lindex $args 1]
  297.             set args [lrange $args 1 end]
  298.         } else {
  299.             set which {extension mode menu}
  300.         }
  301.         foreach type $which {
  302.             if {$type != "extension"} {cache::read index::${type}}
  303.             if [info exists index::${type}($name)] {
  304.                 return [set index::${type}($name)]
  305.             }
  306.         }
  307.         return ""
  308.     }    
  309. }
  310.  
  311. ## 
  312.  # -------------------------------------------------------------------------
  313.  # 
  314.  # "package::_versionCompare" --
  315.  # 
  316.  #  This proc compares the two version numbers.  It returns:
  317.  #  
  318.  #  0 equal
  319.  #  1 equal but beta/patch update
  320.  #  2 equal but minor update
  321.  #  -1 beta/patch version older
  322.  #  -2 minor version older
  323.  #  -3 major version newer
  324.  #  -5 major version older
  325.  #  
  326.  #  i.e. >= 0 is basically ok, < 0 basically bad
  327.  #  
  328.  #  It works for beta, alpha, dev, fc and patch version numbers.
  329.  #  Any sequence of letters starting b,a,d,f,p are assumed to
  330.  #  represent the particular item.
  331.  #  
  332.  #  2.4 > 1.5 > 1.4.3 > 1.4.3b2 > 1.4.3b1 > 1.4.3a75 > 1.4p1 > 1.4
  333.  # -------------------------------------------------------------------------
  334.  ##
  335. proc package::_versionCompare {v1 v2} {
  336.     regsub -all -nocase {([a-z])[a-z]+} $v1 {\1} v1
  337.     regsub -all -nocase {([a-z])[a-z]+} $v2 {\1} v2
  338.     set v1 [split $v1 .p]
  339.     set v2 [split $v2 .p]
  340.     set i -1
  341.     set ret 0
  342.     set mult 2
  343.     while 1 {
  344.         incr i
  345.         set sv1 [lindex $v1 0]
  346.         set sv2 [lindex $v2 0]
  347.         if {$sv1 == "" && $sv2 == ""} { break }
  348.         if {$sv1 == ""} { 
  349.             set v1 [concat 8 0 $v1]
  350.             set v2 [concat 9 $v2]
  351.             continue
  352.         } elseif {$sv2 == ""} { 
  353.             set v1 [concat 9 $v1]
  354.             set v2 [concat 8 0 $v2]
  355.             continue
  356.         } elseif {[regexp -nocase {[a-z]} "$sv1$sv2"]} {
  357.             # beta versions
  358.             foreach v {sv1 sv2} {
  359.                 if [regexp -nocase {[a-z]} [set $v]] {
  360.                     # f = 8, b = 7, a = 6, d = 5
  361.                     regsub -nocase {([^a-z])f} [set $v] {\1 7 } $v
  362.                     regsub -nocase {([^a-z])b} [set $v] {\1 6 } $v
  363.                     regsub -nocase {([^a-z])a} [set $v] {\1 5 } $v
  364.                     regsub -nocase {([^a-z])d} [set $v] {\1 4 } $v
  365.                 } else {
  366.                     # release version = 8, so it is larger than any of the above
  367.                     append $v " 8"
  368.                 }
  369.             }
  370.             set v1 [eval lreplace [list $v1] 0 0 $sv1]
  371.             set v2 [eval lreplace [list $v2] 0 0 $sv2]
  372.             set mult 1
  373.             continue
  374.         }
  375.         if {$sv1 < $sv2} { set ret -1 ; break }
  376.         if {$sv1 > $sv2} { set ret 1 ; break }
  377.         set v1 [lrange $v1 1 end]
  378.         set v2 [lrange $v2 1 end]
  379.     }
  380.     if {$i == 0} {
  381.         # major version, return 0, -3, -5
  382.         return [expr $ret * (-4*$ret + 1)]
  383.     } else {
  384.         return [expr $mult *$ret]
  385.     }
  386. }
  387.  
  388. proc package::reqInstalledVersion {name exact? {reqvers ""}} {
  389.     global index::extension
  390.     # called from installer
  391.     set msg " I suggest you abort the installation."
  392.     if [info exists index::extension($name)] {
  393.         if {[set exact?] == ""} {return}
  394.         set av [alpha::package versions $name]
  395.         if {[set exact?] == "-exact"} {
  396.             if {[alpha::package versions $name] != $reqvers} {
  397.                 alertnote "The installed version $av of '$name' is incorrect.  Exact version $reqvers was requested.$msg"
  398.             }
  399.         } else {
  400.             set reqvers [set exact?]
  401.             if {$reqvers != ""} {        
  402.                 set c [package::_versionCompare $av $reqvers]            
  403.                 if {$c < 0 && $c != -3} {            
  404.                     alertnote "The installed version $av of '$name' is too old. Version $reqvers was requested.$msg"                
  405.                 } elseif {$c == -3} {            
  406.                     alertnote "The installed version $av of '$name' may not be backwards compatible with the requested version ($reqvers).$msg"                
  407.                 }             
  408.             }        
  409.         }
  410.     } else {
  411.         alertnote "This package requires the prior installation of '$name'. It is not currently installed.$msg"
  412.     }
  413. }
  414.  
  415. proc package::install {name version {script ""}} {
  416.     global index::extension
  417.     set index::extension($name) [list $version $script]
  418.     cache::add index-extension variable index::extension($name)
  419. }
  420.  
  421. proc package::checkRequire {pkg} {
  422.     if [catch {alpha::package require $pkg} error] {
  423.         if [catch {alertnote "The '$pkg' package had an error starting up: $error"} ] {
  424.             alertnote "The '$pkg' package had an error starting up"
  425.         }
  426.     }    
  427. }
  428.  
  429.  
  430. proc package::menuProc {dmy pkg} {
  431.     switch -- $pkg {
  432.         " " {
  433.             return
  434.         }
  435.         "autoloadingExtensions" {
  436.             alertnote "Extensions which contain no startup code are just\
  437.               collections of Tcl procedures which are autoloaded when\
  438.               necessary.  Activation/deactivation is not relevant for them."
  439.         }
  440.         "readHelpFileForExtension" {
  441.             alertnote "Select one of the extensions in this menu,\
  442.               while holding a modifier key, and I will try and find its\
  443.               associated help file — sadly, some extensions have no help files."
  444.         } 
  445.         "activateOrDeactivateExtension" {
  446.             alertnote "Select one of the extensions in this menu\
  447.               to activate or deactivate it.  Active extensions are marked\
  448.               with bullets.  Deactivation will usually not take effect until\
  449.               you have restarted Alpha."
  450.         } 
  451.         "describeExtension" {
  452.             alertnote "Select one of the extensions in this menu,\
  453.               while holding 'shift', and I will display some information\
  454.               about that package."
  455.         }
  456.         "describePackage" {
  457.             set pkg [dialog::optionMenu "Describe which package?" \
  458.               [lsort -ignore [alpha::package names]]]
  459.             package::describe $pkg
  460.         }
  461.         "rebuildPackageIndex" {
  462.             alpha::rebuildPackageIndices
  463.         }
  464.         "listPackages" {
  465.             global::listPackages
  466.         }
  467.         "uninstallPackage" {
  468.             package::uninstall
  469.         }
  470.         "installBugFixesFrom" {
  471.             # this item isn't in the menu by default anymore.
  472.             set f [getfile "Select a bug-fix file…"]
  473.             procs::patchOriginalsFromFile $f 1
  474.         }
  475.         default {
  476.             # workaround Alpha bugs (perhaps Mercutio MDEF bug?)
  477.             set pkg [package::buggyAlphaMenu $pkg]
  478.             if [package::helpOrDescribe $pkg] {
  479.                 return
  480.             }
  481.             package::toggle $pkg
  482.         }
  483.     }
  484. }
  485.  
  486. proc package::makeMenu {} {
  487.     global index::extension package::loaded
  488.     set names [lsort -ignore [lremove [alpha::package names -extension] "Alpha"]]
  489.     
  490.     set extList {}
  491.     set autoList [list \
  492.       "<S[menu::itemWithIcon {describeExtension} 81]" \
  493.       "<S<U[menu::itemWithIcon {readHelpFileForExtension} 81]" \
  494.       "<S[menu::itemWithIcon {autoloadingExtensions} 81]"]
  495.     foreach mi $names {
  496.         if {[string trim [lindex [set index::extension($mi)] 1]] == ""} {
  497.             lappend autoList $mi
  498.         } else {
  499.             lappend extList $mi
  500.         }
  501.     }
  502.     
  503.     set m [list "describePackage…" "uninstallPackage…" "listPackages" \
  504.       "rebuildPackageIndex" \
  505.       [list menu -n "autoloadingExtensions" -p package::menu $autoList] \
  506.       "(-" \
  507.       "<S[menu::itemWithIcon {describeExtension} 81]" \
  508.       "<S<U[menu::itemWithIcon {readHelpFileForExtension} 81]" \
  509.       "<S[menu::itemWithIcon {activateOrDeactivateExtension} 81]" "(-"]
  510.     menu -n "packages" -p package::menuProc [concat $m $extList]
  511.     foreach pkg ${package::loaded} {
  512.         if {[markMenuItem "packages" $pkg 1] != ""} {
  513.             # buggy menus
  514.             markMenuItem "packages" [quote::Menuify $pkg] 1
  515.         }
  516.     }
  517. }
  518.  
  519.  
  520. proc package::queryWebForList {} {
  521.     global defaultAlphaDownloadSite remote::site PREFS
  522.     set sitename [dialog::variable defaultAlphaDownloadSite "Query which site?"]
  523.     set nm ${PREFS}:_pkgtemp
  524.     set siteurl [set remote::site($sitename)]
  525.     
  526.     catch {removeFile $nm}
  527.     message "Fetching remote list…"
  528.     set type [url::fetch $siteurl $nm]
  529.     package::okGotTheList $sitename
  530. }
  531.  
  532. ## 
  533.  # -------------------------------------------------------------------------
  534.  # 
  535.  # "package::okGotTheList" --
  536.  # 
  537.  #  Helper proc which we can also call if the listing was interrupted
  538.  #  half-way through.
  539.  # -------------------------------------------------------------------------
  540.  ##
  541. proc package::okGotTheList {{sitename ""}} {
  542.     global defaultAlphaDownloadSite remote::site PREFS
  543.     if {$sitename == ""} {
  544.         set sitename [dialog::variable defaultAlphaDownloadSite "From which site did you get the list?"]
  545.     }
  546.     set type [lindex [url::parse [set remote::site($sitename)]] 0]
  547.     set nm ${PREFS}:_pkgtemp
  548.     if {![file exists $nm] || (![file writable $nm]) || (![file size $nm])} {
  549.         alertnote "There was an error fetching the list.\r\rIf it's still being\
  550.           downloaded, wait till that's done and then select 'Ok Got The List'\
  551.           from the downloads menu."
  552.         enableMenuItem -m alphaDownloads "Ok, Got The List" on
  553.         error "Error fetching list of new packages"
  554.     } else {
  555.         enableMenuItem -m alphaDownloads "Ok, Got The List" off
  556.     }
  557.     set fd [open $nm "r"]
  558.     catch {set lines [split [read $fd] "\n\r"]}
  559.     close $fd
  560.     
  561.     if [catch [list remote::process${type}Listing $lines] listing] {
  562.         alertnote "Error interpreting list of new packages"
  563.         error "Error interpreting list of new packages"
  564.     }
  565.     message "Processing list…"
  566.     remote::processList $sitename $listing
  567.     message "Updated remote package information."
  568. }
  569.  
  570. proc package::active {pkg {text ""}} {
  571.     global package::loaded
  572.     if {[lsearch -exact ${package::loaded} $pkg] != -1} {
  573.         if {$text != ""} { return [lindex $text 0] } else {return 1 }
  574.     } else {
  575.         if {$text != ""} { return [lindex $text 1] } else {return 0 }
  576.     }
  577. }
  578.  
  579. proc package::_editSite {{name ""} {loc ""}} {
  580.     if {$name == ""} {
  581.         set title "Name of new archive site"
  582.         set name "Ken's Alpha site"
  583.         set loc "ftp://ftp.ken.com/pub/Alpha/"
  584.     } else {
  585.         set title "Archive site name"
  586.     }
  587.     set y 10
  588.     set yb 105
  589.     set res [eval dialog -w 420 -h 135 \
  590.         [dialog::textedit $title $name 10 y 40] \
  591.         [dialog::textedit "URL for site" $loc 10 y 40] \
  592.         [dialog::okcancel 250 yb 0]]
  593.     if [lindex $res 3] { error "Cancel" } 
  594.     # cancel was pressed
  595.     return [lrange $res 0 1]    
  596. }
  597.  
  598.  
  599. proc package::addIndex {args} {
  600.     global index::extension pkg_file
  601.     cache::read index::extension
  602.     foreach f [concat $args] {
  603.         set pkg_file $f
  604.         message "scanning $f…"
  605.         catch {source $f}
  606.     }
  607.     cache::create index-extension "variable" index::extension
  608.     unset pkg_file
  609. }
  610.  
  611. proc package::helpFile {pkg {pointer 0}} {
  612.     # read help file instead
  613.     global HOME
  614.     if ![catch {alpha::package help $pkg} res] {
  615.         if {[lindex [set help [lindex $res 1]] 0] == "file"} {
  616.             if {$pointer} {
  617.                 return "Help for this package is located in \"[lindex $help 1]\""
  618.             } else {
  619.                 edit -r -c ${HOME}:Help:[lindex $help 1]
  620.             }
  621.         } elseif {[string index $help 0] == "\["} {
  622.             # evaluate help at toplevel in a silly way!
  623.             # (how else do we do it? besides removing the '[]' of course ;-)
  624.             if {$pointer} {
  625.                 return "You can read help for this package by holding 'shift'\
  626.                   when\ryou select its name in the menu."
  627.             } else {
  628.                 uplevel \#0 switch -- $help {}
  629.             }
  630.         } else {
  631.             if {$pointer} {
  632.                 return $help
  633.             } else {
  634.                 new -n "* '$pkg' Help *"
  635.                 insertText "Help for package '$pkg', version\
  636.                   [alpha::package versions $pkg]\r"
  637.                 insertText $help
  638.                 winReadOnly
  639.             }
  640.         }
  641.         return
  642.     }
  643.     if {!$pointer} {
  644.         alertnote "Sorry, there isn't a help file for that package.\
  645.           You should contact the package maintainer."
  646.     }
  647.     return
  648. }
  649.  
  650. ## 
  651.  # -------------------------------------------------------------------------
  652.  # 
  653.  # "package::helpFilePresent" --
  654.  # 
  655.  #  Help files must be of the same name as the package (minus 'mode' or 
  656.  #  'menu'), but may have any combination of mode, menu, or help after
  657.  #  that name.  Whitespace is irrelevant.
  658.  # -------------------------------------------------------------------------
  659.  ##
  660. proc package::helpFilePresent {args} {
  661.     set res ""
  662.     cache::read index::help
  663.     foreach pkg $args {
  664.         lappend res [info exists index::help($pkg)]
  665.     }
  666.     return $res
  667. }
  668.  
  669. proc package::helpOrDescribe {pkg} {
  670.     if [set mods [expr [getModifiers] & 0xfe]] {
  671.         if {$mods & 34} {
  672.             package::helpFile $pkg
  673.         } else {
  674.             package::describe $pkg
  675.         }
  676.         return 1
  677.     }
  678.     return 0
  679. }
  680.  
  681. proc package::describe {pkg {return 0}} {
  682.     set info [alpha::package info $pkg]
  683.     set type [lindex $info 0]
  684.     set msg "Package '$pkg', version [alpha::package versions $pkg] is a"
  685.     switch -- $type {
  686.         "extension" {
  687.             append msg "n $type, and is [package::active $pkg {active inactive}]."
  688.         }
  689.         "mode" {
  690.             append msg " $type; modes are always active."
  691.         }
  692.         "menu" {
  693.             append msg " $type, and is "
  694.             global globalMenus_curr
  695.             if ![lcontains globalMenus_curr $pkg] {
  696.                 append msg "not "
  697.             }
  698.             append msg "in use."
  699.         }
  700.     }
  701.     cache::read index::maintainer
  702.     if [info exists index::maintainer($pkg)] {
  703.         set p [lindex [set index::maintainer($pkg)] 1]
  704.         append msg "\rMaintainer: [lindex $p 0], [lindex $p 1]\r"
  705.         append msg [lindex $p 2]
  706.     }
  707.     if $return {
  708.         return $msg
  709.     }
  710.     alertnote $msg
  711. }
  712.  
  713. proc package::buggyAlphaMenu {pkg} {
  714.     if [alpha::package exists $pkg] { return $pkg }
  715.     set pkg [join $pkg ""]
  716.     if [alpha::package exists $pkg] { return $pkg }
  717.     set pkg "[string toupper [string index $pkg 0]][string range $pkg 1 end]"
  718.     if [alpha::package exists $pkg] { return $pkg}
  719.     set pkg "[string tolower [string index $pkg 0]][string range $pkg 1 end]"
  720.     if [alpha::package exists $pkg] { return $pkg}
  721.     alertnote "No known package '$pkg'"
  722.     error ""
  723. }
  724.  
  725. proc package::activate {pkg} {
  726.     global index::extension
  727.     if {[string trim [lindex [set index::extension($pkg)] 1]] == ""} {
  728.         alertnote "That package only ever auto-loads when necessary\
  729.           and hence can't be activated."
  730.         return
  731.     }
  732.     if [catch {alpha::package require $pkg}] {
  733.         alertnote "The '$pkg' package had problems starting up."
  734.         error ""
  735.     }
  736. }
  737.  
  738. proc package::markMenu {name val} {
  739.     if {[markMenuItem "packages" $name $val] != ""} {
  740.         # buggy menus
  741.         markMenuItem "packages" [quote::Menuify $name] $val
  742.     }
  743. }
  744.  
  745. proc package::deactivate {pkg} {
  746.     global package::activate modifiedVars package::loaded index::extension
  747.     if {[string trim [lindex [set index::extension($pkg)] 1]] == ""} {
  748.         alertnote "That package only ever auto-loads when necessary\
  749.           and hence can't be deactivated."
  750.         return
  751.     }
  752.     if ![catch {alpha::package disable $pkg} script] {
  753.         # has a disable script
  754.         if [catch {uplevel #0 $script}] {
  755.             alertnote "$pkg had a problem disabling itself"
  756.         }
  757.     }
  758.     package::markMenu $pkg 0
  759.     if [info exists package::activate] {
  760.         set package::activate [lremove ${package::activate} $pkg]
  761.         lappend modifiedVars package::activate
  762.     }
  763.     set package::loaded [lremove ${package::loaded} $pkg]
  764.     message "That may only take effect after restarting Alpha."
  765. }
  766.  
  767. proc package::toggle {pkg} {
  768.     global package::loaded
  769.     if [lcontains package::loaded $pkg] {
  770.         # deactivate it
  771.         package::deactivate $pkg
  772.     } else {
  773.         package::activate $pkg
  774.     }
  775. }
  776.  
  777. proc package::uninstall {} {
  778.     cache::read index::uninstall
  779.     if {[set pkgs [array names index::uninstall]] == ""} {
  780.         alertnote "I don't know how to uninstall anything."
  781.         return
  782.     }
  783.     set pkg [dialog::optionMenu "Permanently remove which package/mode/menu?" [lsort -ignore $pkgs]]
  784.     if {![dialog::yesno "Are you absolutely sure you want to uninstall $pkg?"]} { 
  785.         return 
  786.     }
  787.     global pkg_file
  788.     set pkg_file [lindex [set index::uninstall($pkg)] 1]
  789.     set script [lindex [set index::uninstall($pkg)] 2]
  790.     if [regexp "rm -r .*" $script check] {
  791.         if {![dialog::yesno "This uninstaller contains a recursive removal command '$check'. Do you want to do this?"]} { 
  792.             return 
  793.         }
  794.     }
  795.     if [catch "uplevel \#0 [list $script]"] {
  796.         alertnote "The uninstaller had problems!"
  797.     }
  798.     if {[dialog::yesno "All indices must now be rebuilt.\rShall I do this for you?"]} {
  799.         alpha::rebuildPackageIndices
  800.         rebuildTclIndices
  801.         auto_reset
  802.     } else {
  803.         alertnote "This will probably cause problems."
  804.     }
  805.     if {[dialog::yesno "It is recommended that you quit and restart Alpha.  Quit now?"]} {
  806.         quit
  807.     }
  808. }
  809.  
  810.  
  811. ## 
  812.  # -------------------------------------------------------------------------
  813.  # 
  814.  # "date::isOlder" --
  815.  # 
  816.  #  {Aug 22 1996} {Mar 26 22:17}
  817.  #  
  818.  # We assume the format is 'Month Day Year' or 'Month Day Time', where
  819.  # a time is distinguished by the presence of a colon.  Months have
  820.  # to be the standard three letter abbreviation (seems ok for all
  821.  # ftp and http servers I've come across)
  822.  # -------------------------------------------------------------------------
  823.  ##
  824. proc date::isOlder {a b} {
  825.     if {$a == $b} { return 0 }
  826.     regexp {(\w+)[ \t]+(\w+)[ \t]+([\w:]+)} $a "" am ad ay
  827.     regexp {(\w+)[ \t]+(\w+)[ \t]+([\w:]+)} $b "" bm bd by
  828.     # check year
  829.     set thisy [lindex [lindex [mtime [now] abbrev] 0] 3]
  830.     if {$ay == $thisy} { set ay "00:00" }
  831.     if {$by == $thisy} { set by "00:00" }
  832.     set a_ist [regexp : $ay]
  833.     set b_ist [regexp : $by]
  834.     if {!$a_ist && !$b_ist} {
  835.         if { $ay < $by } { return 1 } elseif {$by < $ay} { return 0}
  836.     }
  837.     if {$a_ist && !$b_ist} { return 0 }
  838.     if {!$a_ist && $b_ist} { return 1 }
  839.     # both are a year or both are times and yrs equal
  840.     set months {Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec}
  841.     set am [lsearch $months $am]
  842.     set bm [lsearch $months $bm]
  843.     if {$am < $bm} { return 1 } elseif {$bm < $am} { return 0 }
  844.     if {$ad < $bd} { return 1 } elseif {$bd < $ad} { return 0 }
  845.     if {$a_ist && $b_ist} {
  846.         regsub {:} $ay {.} ay
  847.         regsub {:} $by {.} by
  848.         if { $ay < $by } { return 1 } elseif {$by < $ay} { return 0}
  849.     } 
  850.     # same !
  851.     return 0
  852. }
  853.  
  854.  
  855. # ◊◊◊◊ Handle remote menu ◊◊◊◊ #
  856. proc remote::menuProc {menu item} {
  857.     global remote::site modifiedArrVars defaultAlphaDownloadSite
  858.     switch -- $item {
  859.         "Update List From A Web Archive Site" {
  860.             package::queryWebForList
  861.         }
  862.         "Ok, Got The List" {
  863.             package::okGotTheList
  864.         }
  865.         "Add Web Or Ftp Archive Site" {
  866.             array set remote::site [package::_editSite]
  867.             lappend modifiedArrVars remote::site
  868.         }
  869.         "Edit Web Or Ftp Archive Site" {
  870.             set sitename [dialog::optionMenu "Edit which site?" \
  871.                 [lsort -ignore [array names remote::site]]]
  872.             
  873.             array set remote::site \
  874.                 [package::_editSite $sitename [set remote::site($sitename)]]
  875.             lappend modifiedArrVars remote::site
  876.         }
  877.         "Remove Web Or Ftp Archive Site" {
  878.             set sitename [dialog::optionMenu "Remove which site?" \
  879.                 [lsort -ignore [array names remote::site]]]
  880.             unset remote::site($sitename)
  881.             lappend modifiedArrVars remote::site
  882.         }
  883.         "Describe Item" {
  884.             alertnote "Select one of the packages, and I'll tell you\
  885.               when it was last modified, and from where it would be downloaded."
  886.         }
  887.         "Ignore Item" {
  888.             alertnote "'Ignoring' a package tells me to remove it from\
  889.               new and updated package lists.  It'll still be listed lower\
  890.               down in the menu"
  891.         }
  892.         "Select Item To Download" {
  893.             alertnote "Select one of the packages, and it will be\
  894.               downloaded from its site on the internet, decompressed\
  895.               and installed."
  896.         }
  897.         default {
  898.             remote::get $item
  899.         }
  900.     }
  901.     
  902. }
  903.  
  904.  
  905. proc remote::makeDownloadsMenu {} {
  906.     global remote::listing
  907.     set l [list "Update List From A Web Archive Site…" \
  908.       "(Ok, Got The List" \
  909.       "<E<SRemove Web Or Ftp Archive Site…" \
  910.       "<S<BEdit Web Or Ftp Archive Site…" \
  911.       "<SAdd Web Or Ftp Archive Site…" "(-" \
  912.       "<S[menu::itemWithIcon {Describe Item} 81]" \
  913.       "<S<U[menu::itemWithIcon {Ignore Item} 81]" \
  914.       "<S[menu::itemWithIcon {Select Item To Download} 81]" ]
  915.     foreach a ${remote::listing} {
  916.         set type [lindex $a 1]
  917.         regsub -all {\.(sit|bin|hqx)} [set name [lindex $a 2]] "" name
  918.         lappend [lindex {other gone new uptodate update} [expr $type + 2]] $name
  919.         if {$type == -1} {
  920.             lappend disable $name
  921.         }
  922.     }
  923.     if [info exists update] {
  924.         lappend l "(-" "/\x1e(Updated items^[text::Ascii 79 1]"
  925.         eval lappend l [lsort -ignore $update]
  926.     }
  927.     if [info exists new] {
  928.         lappend l "(-" "/\x1e(New items^[text::Ascii 79 1]"
  929.         eval lappend l [lsort -ignore $new]
  930.     }
  931.     if [info exists uptodate] {
  932.         lappend l "(-" "(Current items"
  933.         eval lappend l [lsort -ignore $uptodate]
  934.     }
  935.     if [info exists other] {
  936.         lappend l "(-" "(Other items"
  937.         eval lappend l [lsort -ignore $other]
  938.     }
  939.     if [info exists gone] {
  940.         lappend l "(-" "(Vanished items"
  941.         eval lappend l [lsort -ignore $gone]
  942.     }
  943.     menu -n "alphaDownloads" -m -p remote::menuProc $l
  944.     if [info exists disable] {
  945.         foreach a $disable {
  946.             enableMenuItem "alphaDownloads" $a off
  947.         }
  948.     }
  949. }
  950.  
  951. proc remote::processftpListing {lines} {
  952.     set files {}
  953.     foreach f [cdr [lreplace $lines end end]] {
  954.         set nm [lindex $f end]
  955.         if {[string length $nm]} {
  956.             if {[string match "d*" $f]} {
  957.                 #lappend files "$nm/"
  958.             } else {
  959.                 regexp {[A-Z].*$} [lreplace $f end end] time
  960.                 set date [lindex $time end]
  961.                 if {![regexp {^19[89][0-5]$} $date]} {
  962.                     # reject anything pre 1996
  963.                     lappend files [list $nm $time]
  964.                 }
  965.             }
  966.         }
  967.     }
  968.     return $files
  969. }
  970.  
  971. ## 
  972.  # -------------------------------------------------------------------------
  973.  # 
  974.  # "remote::processhttpListing" --
  975.  # 
  976.  #  Extract all things like  <A HREF="/~vince/pub/">Parent Directory</A>
  977.  #  followed by a date.  Massage the date into 'Month day year'.
  978.  #  
  979.  #  I don't know if this will work for all http servers!  It works for
  980.  #  mine.
  981.  # -------------------------------------------------------------------------
  982.  ##
  983. proc remote::processhttpListing {lines} {
  984.     set files {}
  985.     foreach f $lines {
  986.         if [regexp {<A HREF="([^"]*)">.*</A>[ \t]*([^ \t]+)[ \t]} $f "" name date] {
  987.             if ![regexp {/$} $name] {
  988.                 if {![regexp {[89][0-5]$} $date]} {
  989.                     # reject anything pre 1996
  990.                     set date [split $date -]
  991.                     set md "[lindex $date 1] [lindex $date 0] "
  992.                     append md [expr [lindex $date 2] < 80 ? 20 : 19]
  993.                     append md [lindex $date 2]
  994.                     lappend files [list $name $md]
  995.                 }
  996.             }
  997.         }
  998.     }
  999.     return $files
  1000. }
  1001.  
  1002. proc remote::versionOneNewer {one two} {
  1003.     return 1
  1004. }
  1005.  
  1006. proc remote::processList {sitename {l ""}} {
  1007.     global remote::listing modifiedVars
  1008.     # removed vanished items from the menu
  1009.     regsub -all {(\.|-)[0-9]+([a-zA-Z][0-9]+)?} [set ll $l] "" ll
  1010.     foreach i ${remote::listing} {
  1011.         if [string match "*${sitename}*" $i] {
  1012.             regsub -all {(\.|-)([0-9]+([a-zA-Z][0-9]+)?)} \
  1013.               [set ii [lindex $i 2]] "" ii
  1014.             if {[lsearch -glob $ll "$ii *"] == -1} {
  1015.                 # it's vanished
  1016.                 lappend removed $i
  1017.                 lappend _removed [lindex $i 0]
  1018.             }
  1019.         }
  1020.     }
  1021.     if [info exists removed] {
  1022.         set remote::listing [lremove -l ${remote::listing} $removed]
  1023.     }
  1024.     # process new items
  1025.     foreach i $l {
  1026.         set namepart [lindex $i 0]
  1027.         set timepart [lindex $i 1]
  1028.         regsub -all {\.(sit|bin|hqx|tcl)} [set name $namepart] "" name
  1029.         regsub -all {(\.|-)[0-9]+([a-zA-Z][0-9]+)?} $name "" name
  1030.         if {[set idx [lsearch -glob ${remote::listing} "${name} *"]] != -1} {
  1031.             # update old item
  1032.             set item [lindex ${remote::listing} $idx]
  1033.             if {[lindex $item 2] != $namepart} {
  1034.                 # it's changed
  1035.                 set item [lreplace $item 1 end 2 $namepart $timepart $sitename]
  1036.                 set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1037.                 lappend _updated $name
  1038.             } elseif {[date::isOlder [lindex $item 3] $timepart]} {
  1039.                 # date has changed
  1040.                 set item [lreplace $item 1 end 2 $namepart $timepart $sitename]
  1041.                 set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1042.                 lappend _updated $name
  1043.             }
  1044.         } else {
  1045.             # new package
  1046.             lappend remote::listing [list $name 0 $namepart $timepart $sitename]
  1047.             lappend _new $name
  1048.         }
  1049.         
  1050.     }
  1051.     lappend modifiedVars remote::listing
  1052.     remote::makeDownloadsMenu
  1053.     package::makeMenu
  1054.     ensureset _updated "none"
  1055.     ensureset _new "none"
  1056.     ensureset _removed "none"
  1057.     if [catch {alertnote "Remote information, NEW: $_new, UPDATED: $_updated, REMOVED: ${_removed}."}] {
  1058.         alertnote "Remote information, [llength $_new] new, [llength $_updated] updated and [llength $_removed] packages removed."
  1059.     }
  1060. }
  1061. proc remote::updateDatabase {idx val} {
  1062.     global remote::listing
  1063.     set item [lindex ${remote::listing} $idx]
  1064.     if {[lindex $item 1] != $val} {
  1065.         # it's changed
  1066.         set item [lreplace $item 1 1 $val]
  1067.         set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1068.     }
  1069. }
  1070.  
  1071. proc remote::pkgIndex {name} { 
  1072.     global remote::listing
  1073.     if {[set i [lsearch -glob ${remote::listing} "${name} *"]] == -1} {
  1074.         set i [lsearch -glob ${remote::listing} \
  1075.             "[string toupper [string index ${name} 0]][string range $name 1 end] *"]
  1076.     }
  1077.     return $i
  1078. }
  1079.  
  1080. proc remote::pkgDetails {name} { 
  1081.     global remote::listing
  1082.     set idx [lsearch -glob ${remote::listing} "${name} *"]
  1083.     return [lindex ${remote::listing} $idx]
  1084. }
  1085.  
  1086. proc remote::get {pkg} {
  1087.     global remote::listing HOME remote::site downloadFolder
  1088.     # get pkg
  1089.     if {[set idx [remote::pkgIndex $pkg]] == -1} {
  1090.         alertnote "Sorry, I don't know from where to download that package."
  1091.         error ""
  1092.     }
  1093.     set item [lindex ${remote::listing} $idx]
  1094.     
  1095.     if [set mods [expr [getModifiers] & 0xfe]] {
  1096.         if {$mods & 34} {
  1097.             # just shift key demote the item in the hierarchy
  1098.             set itm [lindex $item 1]
  1099.             if {$itm == 0 || $itm == 2} { set itm 1 } else { set itm -2 }
  1100.             set item [lreplace $item 1 1 $itm]
  1101.             set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1102.             global modifiedVars
  1103.             lappend modifiedVars remote::listing
  1104.             remote::makeDownloadsMenu
  1105.             message "Package '$pkg' demoted."
  1106.             return
  1107.         } else {
  1108.             # describe the item
  1109.             alertnote "File '[lindex $item 2]', last modified [lindex $item 3], to be downloaded from [lindex $item 4], at [set remote::site([lindex $item 4])]"
  1110.             return
  1111.         }
  1112.     }
  1113.     set file [lindex $item 2]
  1114.     set sitename [lindex $item 4]
  1115.     # get the file
  1116.     if {![file exists $downloadFolder] || ![file isdirectory $downloadFolder]} {
  1117.         alertnote "Your Download Folder does not exists.  I'll download to\
  1118.           Alpha's home directory."
  1119.         set downloadFolder $HOME
  1120.     }
  1121.     if [catch {url::fetchFrom [set remote::site($sitename)] ${downloadFolder}: $file} err] {
  1122.         alertnote "Fetch error '$err'"
  1123.         error ""
  1124.     }
  1125.     # update database
  1126.     remote::updateDatabase $idx 1
  1127.     remote::makeDownloadsMenu
  1128.     package::makeMenu
  1129.     # install
  1130.     set filepre [lindex [split $file .] 0]
  1131.     # unstuff (this may happen automatically)
  1132.     foreach ext {.hqx .bin .sit} {
  1133.         set stuffed [glob -nocomplain "${downloadFolder}:${filepre}*${ext}"]
  1134.         if {[llength $stuffed] == 1} {
  1135.             set ff [lindex $stuffed 0]
  1136.             message "Decompressing [file tail $ff]…"
  1137.             set name [file tail [app::launchFore SITx]]
  1138.             sendOpenEvent -r 'SITx' $ff
  1139.         }
  1140.     }
  1141.     # install
  1142.     set files [glob -nocomplain -t TEXT "${downloadFolder}:${filepre}*"]
  1143.     if {[llength $files] == 0} {
  1144.         # look for directory
  1145.         set dirs [glob -nocomplain "${downloadFolder}:${filepre}*:"]
  1146.         if {[llength $dirs] == 1} {
  1147.             set local [lindex $dirs 0]
  1148.             set files [glob -nocomplain -t TEXT "${local}*\[i|I\]{nstall,NSTALL}"]
  1149.         } else {
  1150.             set files ""
  1151.             set local $downloadFolder
  1152.         }
  1153.     }
  1154.     if {[llength $files] == 0} {
  1155.         alertnote "I can't find a suitable, unique install file.  You must find it yourself."
  1156.         # open dir in finder
  1157.         openFolder $local
  1158.         switchTo Finder
  1159.         return
  1160.     }
  1161.     if {[llength $files] > 1} {
  1162.         set f [listpick -p "Which file is the installer?" $files]
  1163.     } else {
  1164.         set f [lindex $files 0]
  1165.     }
  1166.     edit $f
  1167.     global mode
  1168.     if {$mode != "Inst"} {
  1169.         alertnote "I don't know what to do with this package from here."
  1170.     } else {
  1171.         if {[dialog::yesno "You can install this extension from the install menu.\rShall I do that for you?"]} {
  1172.             install::installThisPackage
  1173.         }
  1174.     }
  1175. }
  1176.  
  1177.